home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / ngenerics.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-17  |  12.0 KB  |  586 lines
  1. /*
  2.   * New Generic function interface for feel
  3.   *
  4.   */
  5.  
  6.  /*
  7.    functions:
  8.    
  9.    generic_apply (gf, arglist)
  10.    call_method(meth, sig, args)
  11.    set_compute_function(lisp function)
  12.    sundry accessors
  13.    This approach has lots of advantages....
  14.  
  15.    if generic_apply fails, we call the function
  16.    'compute_and_apply_method' which should 
  17.    1) calculate method to apply
  18.    2) stash the method in a cache
  19.    3) call it via call_method
  20.    
  21.    */
  22. /*
  23.   Data structures:
  24.   A table is a cons structure for accessing via a list    
  25.   format: 
  26.  
  27.   fast cache: (last-method-call-sig result)
  28.   slow cache: table of methods, keying (sig+methods)
  29.               --- keep the sig as we don't want to recontruct it.
  30. */
  31.  
  32. #include "defs.h"
  33. #include "structs.h"
  34. #include "funcalls.h"
  35.  
  36. #include "global.h"
  37. #include "error.h"
  38. #include "allocate.h"
  39. #include "ngenerics.h"
  40. #include "bootstrap.h"
  41. #include "class.h"
  42. #include "bvf.h"
  43. #include "modules.h"
  44. #include "symboot.h"
  45. #include "specials.h"
  46. #include "modboot.h"
  47. #include "calls.h"
  48. #include "streams.h"
  49.  
  50. static LispObject sym_signature;
  51. static LispObject sym_qualifiers;
  52.  
  53. static LispObject sym_lambda_list;
  54. static LispObject sym_method_class;
  55.  
  56. static LispObject method_status_handle;
  57. static LispObject method_args_handle;
  58.  
  59. static EUFUN_1( Fn_generic_function_p, obj)
  60. {
  61.   return((is_generic(obj) ? lisptrue : nil));
  62. }
  63. EUFUN_CLOSE
  64.  
  65. static EUFUN_1( Fn_methodp, obj)
  66. {
  67.   return((is_method(obj) ? lisptrue : nil));
  68. }
  69. EUFUN_CLOSE
  70.  
  71. /* Time waster functions */
  72.  
  73. LispObject generic_apply_4(LispObject *stacktop, LispObject gf,
  74.                LispObject a1, LispObject a2,
  75.                LispObject a3, LispObject a4)
  76. {
  77.   LispObject *stackbase=stacktop;
  78.   STACK_TMP(a1); STACK_TMP(a2); STACK_TMP(a3); STACK_TMP(a4);
  79.   
  80.   return(generic_apply(stackbase,gf));
  81. }
  82.  
  83. LispObject generic_apply_3(LispObject *stacktop,LispObject gf,
  84.                LispObject a1, LispObject a2, LispObject a3)
  85. {
  86.   LispObject *stackbase=stacktop;
  87.   STACK_TMP(a1); STACK_TMP(a2); STACK_TMP(a3);
  88.   return(generic_apply(stackbase,gf));
  89. }
  90.  
  91. LispObject generic_apply_2(LispObject *stacktop,LispObject gf,LispObject a1, LispObject a2)
  92. {
  93.   LispObject *stackbase=stacktop;
  94.   STACK_TMP(a1); STACK_TMP(a2); 
  95.   return(generic_apply(stackbase,gf));
  96. }
  97.  
  98. LispObject generic_apply_1(LispObject *stacktop, LispObject gf,
  99.                LispObject a1)
  100. {
  101.   LispObject *stackbase=stacktop;
  102.   STACK_TMP(a1); 
  103.   return(generic_apply(stackbase,gf));
  104. }
  105.  
  106. #define TRACE_GCALLS
  107. #ifdef TRACE_GCALLS
  108. #define ON_TRACE(x) x
  109. int fasthits=0;
  110. int slowhits=0;
  111. int gcalls=0;
  112. #else
  113. #define ON_TRACE(x)
  114. #endif
  115.  
  116. LispObject generic_apply(LispObject *stackbase,LispObject gf)
  117. {
  118.   LispObject compute_and_apply_method(LispObject *);
  119.   LispObject call_method(LispObject *,int,LispObject);
  120.   LispObject *stacktop, *walker;
  121.   LispObject ptr,args,fastcache,slowcache;
  122.   int count, nargs,explicit,extras,depth;
  123.  
  124.   ON_TRACE(gcalls++);
  125.   if (intval(generic_argtype(gf)) >= 0) {
  126.     explicit = intval(generic_argtype(gf));
  127.     extras = FALSE;
  128.   }
  129.   else {
  130.     explicit = -intval(generic_argtype(gf))-1;
  131.     extras = TRUE;
  132.   }
  133.   nargs=explicit+(extras ? 1 : 0);
  134.   
  135.   stacktop=stackbase+nargs;
  136.  
  137.   /* fast cache first */
  138.   fastcache=(generic_fast_method_cache(gf));
  139.   slowcache=(generic_slow_method_cache(gf));
  140.   /* is there a cache ? */
  141.   if (fastcache!=nil)
  142.     {
  143.       /** Method lookup **/
  144.       ptr=CAR(fastcache); /* nb car(nil)==nil */
  145.       walker=stackbase;
  146.       
  147.       while (ptr!=nil && CAR(ptr)==classof(*(walker)))
  148.     {
  149.       walker++;
  150.       ptr=CDR(ptr);
  151.     }
  152.       if (ptr==nil)
  153.     { ON_TRACE(fasthits++);
  154.       return(call_method(stackbase,nargs,
  155.                  CDR(fastcache)));
  156.     }
  157.  
  158.       /* then the slow cache */
  159.  
  160.       ptr=slowcache;
  161.       walker=stackbase;
  162.       count=0;
  163.       depth=intval(generic_discrimination_depth(gf));
  164.  
  165.       while(ptr!=nil && count<depth)
  166.     {
  167.       if (CAR(CAR(ptr))==classof(*(walker)))
  168.         {            /* move down 1 */
  169.           ptr=CDR(CAR(ptr));
  170.           walker++;
  171.           count++;
  172.         }
  173.       else
  174.         ptr=CDR(ptr);
  175.     }
  176.       
  177.       if (count==depth)
  178.     {
  179.       generic_fast_method_cache(gf)=ptr;
  180.       ON_TRACE(slowhits++);
  181.       return(call_method(stackbase,nargs,CDR(ptr)));
  182.     }
  183.       /* not in slow cache */
  184.     }
  185.  
  186.   STACK_TMP(gf);
  187.   /** find Args **/
  188.   args=allocate_n_conses(stacktop,nargs);
  189.   ptr=args;
  190.  
  191.   walker=stackbase;
  192.   count=0;
  193.   while (count<nargs)
  194.     {
  195.       CAR(ptr)= *walker;
  196.       ptr=CDR(ptr);
  197.       ++walker;
  198.       ++count;
  199.     }
  200.   UNSTACK_TMP(gf);
  201.  
  202.   return(EUCALL_2(compute_and_apply_method,gf, args));
  203.   
  204. }    
  205.  
  206. LispObject call_method(LispObject *stackbase, int nargs, LispObject ml)
  207. {
  208.   LispObject mf;
  209.  
  210.   if (!is_method(CAR(ml)))
  211.     CallError(stackbase,"call-method: Not a method\n",nil,NONCONTINUABLE);
  212.   
  213.   mf = method_function(CAR(ml));
  214.  
  215. #ifdef BCI
  216.   if (is_b_function(mf))
  217.     return(apply_nary_bytefunction(stackbase,nargs,ml));
  218.   
  219. #ifdef WITH_SPECIAL_METHODS
  220.   if (is_special_method(mf))
  221.     return(apply_special_method(stackbase,nargs,mf));
  222. #endif
  223. #endif
  224.  
  225.   if (is_c_function(mf)) {
  226.     return((mf->C_FUNCTION.func)(stackbase));
  227.   }
  228.  
  229.   /* Should we check the arity of the function --- no add method should. */
  230.   if (is_i_function(mf) || is_e_function(mf)) 
  231.     { /* Should I make the env and apply here ? */
  232.       LispObject *walker,*stacktop;
  233.       LispObject args,ret,ptr;
  234.       int count;
  235.       
  236.       stacktop=stackbase+nargs;
  237.  
  238.       STACK_TMP(mf);
  239.       STACK_TMP(CDR(ml));
  240.  
  241.       /* one method list, one arg list */
  242.       args=allocate_n_conses(stacktop,nargs+2); 
  243.       UNSTACK_TMP(ml);  
  244.       CAR(args)=ml;     /* Arg 1: arg list */
  245.       ptr=CDR(args);
  246.       CAR(ptr)=CDR(ptr);  /* Arg 2: Arguments */
  247.       
  248.       ptr=CDR(ptr);
  249.       walker=stackbase;
  250.       count=0;
  251.       
  252.       while (count<nargs)
  253.     {
  254.       CAR(ptr)= *walker;
  255.       ptr=CDR(ptr);
  256.       ++walker;
  257.       ++count;
  258.     }
  259.       
  260.       UNSTACK_TMP(mf);
  261.       count=0;
  262.       ptr=args;
  263.       while (count<nargs+2)
  264.     {
  265.       *(stackbase+count)=CAR(ptr);
  266.       ptr=CDR(ptr);    
  267.       count++;
  268.     }
  269.  
  270.       stacktop=stackbase;
  271.       ret=module_apply_args(stacktop,count,mf);
  272.       return ret;
  273.     }
  274.  
  275.  
  276.   CallError(stackbase,
  277.         "call method: unknown method function class",mf,NONCONTINUABLE);
  278.  
  279.   return(nil);
  280. }
  281.  
  282. /* repeat of last, but with args passed in a list this time... */
  283. static EUFUN_2(call_method_by_list,ml , args)
  284. {
  285.   LispObject mf;
  286.  
  287.   if (!is_method(CAR(ml)))
  288.     CallError(stacktop,"Not a method\n",nil,NONCONTINUABLE);
  289.  
  290.  
  291.   mf = method_function(CAR(ml));
  292.  
  293.   if (is_i_function(mf) || is_e_function(mf)) {
  294.     LispObject allargs,ret;
  295.  
  296.     STACK_TMP(mf);
  297.     EUCALLSET_2(allargs, Fn_cons,args,args);
  298.     EUCALLSET_2(allargs, Fn_cons,CDR(ml),allargs);
  299.     UNSTACK_TMP(mf);
  300.  
  301.     EUCALLSET_2(ret,module_mv_apply_1,mf,allargs);
  302.     return ret;
  303.   }
  304.  
  305.   if (is_c_function(mf)) 
  306.     {
  307.       LispObject ret;
  308.  
  309.       EUCALLSET_2(ret,module_mv_apply_1,mf,args);
  310.       return ret;
  311.     }
  312.  
  313. #ifdef BCI
  314.   if (is_b_function(mf))
  315.     {    
  316.       LispObject *ptr=stackbase;
  317.       int i=0;
  318.  
  319.       while (is_cons(args))
  320.     {
  321.       *ptr=CAR(args);
  322.       args=CDR(args);
  323.       ptr++;
  324.       i++;
  325.     }
  326.       return(apply_nary_bytefunction(stackbase,i,ml));
  327.     }
  328.  
  329. #ifdef WITH_SPECIAL_METHODS
  330.   if (is_special_method(mf))
  331.     {
  332.       LispObject lst=args;
  333.       LispObject *ptr=stackbase;
  334.       int nargs=0;
  335.  
  336.       while (is_cons(lst))
  337.     {
  338.       *ptr=CAR(lst);
  339.       lst=CDR(lst);
  340.       ptr++;
  341.       nargs++;
  342.     }
  343.       return (apply_special_method(stackbase,nargs,mf));
  344.     }
  345. #endif 
  346. #endif /* BCI */
  347.   CallError(stacktop,
  348.             "call method: unknown method function class",mf,NONCONTINUABLE);
  349.  
  350.   return(nil);
  351. }
  352. EUFUN_CLOSE
  353.  
  354. /** accessors and dull stuff **/
  355.  
  356. static EUFUN_1(Fn_generic_slow_method_cache,gf)
  357. {
  358.   return generic_slow_method_cache(gf);
  359. }
  360. EUFUN_CLOSE
  361.  
  362. static EUFUN_1(Fn_generic_fast_method_cache,gf)
  363. {
  364.   return generic_fast_method_cache(gf);
  365. }
  366. EUFUN_CLOSE
  367.  
  368. static EUFUN_2(Fn_generic_slow_method_cache_setter,gf, value)
  369. {
  370.   return generic_slow_method_cache(gf)=value;
  371. }
  372. EUFUN_CLOSE
  373.  
  374. static EUFUN_2(Fn_generic_fast_method_cache_setter,gf, value)
  375. {
  376.   generic_fast_method_cache(gf)=value;
  377.   return nil;
  378. }
  379. EUFUN_CLOSE
  380.  
  381. static EUFUN_1(Fn_generic_name,gf)
  382. {
  383.   if (!is_generic(gf))
  384.     CallError(stacktop,"generic-method-name: Not a generic",gf,NONCONTINUABLE);
  385.  
  386.   return generic_name(gf);
  387. }
  388. EUFUN_CLOSE
  389.  
  390. static EUFUN_1(Fn_generic_method_class,gf)
  391. {
  392.   if (!is_generic(gf))
  393.     CallError(stacktop,"generic-method-class: Not a generic",gf,NONCONTINUABLE);
  394.  
  395.   return generic_method_class(gf);
  396. }
  397. EUFUN_CLOSE
  398.  
  399. static EUFUN_1(Fn_generic_method_table,gf)
  400. {
  401.   if (!is_generic(gf))
  402.     CallError(stacktop,"generic-method-table: Not a generic",gf,NONCONTINUABLE);
  403.  
  404.   return generic_method_table(gf);
  405. }
  406. EUFUN_CLOSE
  407.  
  408. static EUFUN_2(Fn_generic_method_table_setter,gf, value)
  409. {
  410.   return generic_method_table(gf)=value;
  411. }
  412. EUFUN_CLOSE
  413.  
  414. static EUFUN_1(Fn_generic_discriminator,gf)
  415. {
  416.   return generic_discriminator(gf);
  417. }
  418. EUFUN_CLOSE
  419.  
  420. static EUFUN_2(Fn_generic_discriminator_setter,gf, value)
  421. {
  422.   return generic_discriminator(gf)=value;
  423. }
  424. EUFUN_CLOSE
  425.  
  426. static EUFUN_1(Fn_generic_discrimination_depth,gf)
  427. {
  428.   return generic_discrimination_depth(gf);
  429. }
  430. EUFUN_CLOSE
  431.  
  432. static EUFUN_2(Fn_generic_discrimination_depth_setter,gf, value)
  433. {
  434.   return generic_discrimination_depth(gf)=value;
  435. }
  436. EUFUN_CLOSE
  437.  
  438.  
  439. static EUFUN_1(Fn_generic_setter,gf)
  440. {
  441.   return generic_setter(gf);
  442. }
  443. EUFUN_CLOSE
  444.  
  445. static EUFUN_2(Fn_generic_setter_setter,gf, value)
  446. {
  447.   return generic_setter(gf)=value;
  448. }
  449. EUFUN_CLOSE
  450.  
  451. /* Method accessors */
  452.  
  453. static EUFUN_1(Fn_method_signature, meth)
  454. {
  455.   return method_signature(meth);
  456. }
  457. EUFUN_CLOSE
  458.  
  459. /***
  460.   ** Callback definition... 
  461.   **/
  462.  
  463. static LispObject Cb_compute_and_apply_method;
  464.  
  465. EUFUN_2(compute_and_apply_method, gf, args)
  466. {
  467.   LispObject xx;
  468.   EUCALLSET_2(xx,Fn_cons,args,nil);
  469.   EUCALLSET_2(xx,Fn_cons,ARG_0(stackbase),xx);
  470.   
  471.   stacktop=stackbase;
  472.   return EUCALL_2(module_mv_apply_1,CAR(Cb_compute_and_apply_method),xx);
  473. }
  474. EUFUN_CLOSE
  475.  
  476. EUFUN_1(Fn_set_compute_fn,val)
  477. {
  478.   CAR(Cb_compute_and_apply_method)=val;
  479.   return nil;
  480. }
  481. EUFUN_CLOSE
  482.  
  483. /***
  484.   ** Initialising objects 
  485.   **
  486.  ***/
  487. ON_TRACE(
  488.      EUFUN_0(print_hits)
  489.      {
  490.        char buf[256];
  491.        sprintf(buf,"Calls: %d fast: %d (%d%%) slow: %d (%d%%)",
  492.            gcalls,fasthits,(fasthits*100)/gcalls,slowhits,(slowhits*100)/gcalls);
  493.        print_string(stacktop,StdOut(),buf);
  494.        return nil;
  495.      }    
  496.      EUFUN_CLOSE
  497.      )
  498.  
  499. extern MODULE Module_generics;
  500.  
  501. /* Initialisation of the module */
  502. #ifdef TRACE_GCALLS
  503. #define GENERICS_ENTRIES 5
  504. #else
  505. #define GENERICS_ENTRIES 4
  506. #endif
  507.  
  508. MODULE Module_generics;
  509. LispObject Module_generics_values[GENERICS_ENTRIES];
  510.  
  511. void initialise_generics(LispObject *stacktop)
  512. {
  513.   Cb_compute_and_apply_method=EUCALL_2(Fn_cons,nil,nil);
  514.   add_root(&Cb_compute_and_apply_method);
  515.  
  516.   method_args_handle = get_symbol(stacktop,"***method-args-handle***");
  517.   add_root(&method_args_handle);
  518.   method_status_handle = get_symbol(stacktop,"***method-status-handle***");
  519.   add_root(&method_status_handle);
  520.  
  521.   sym_signature = get_symbol(stacktop,"signature");
  522.   add_root(&sym_signature);
  523.   sym_qualifiers = get_symbol(stacktop,"qualifiers");
  524.   add_root(&sym_qualifiers);
  525.  
  526.   open_module(stacktop,
  527.           &Module_generics,
  528.           Module_generics_values,
  529.           "generics",
  530.           GENERICS_ENTRIES);
  531.  
  532.   (void) make_module_function(stacktop,"generic-function-p",Fn_generic_function_p,1);
  533.   (void) make_module_function(stacktop,"methodp",Fn_methodp,1);
  534.  
  535.   (void) make_module_function(stacktop,"set-compute-and-apply-fn",Fn_set_compute_fn,1);
  536.   (void) make_module_function(stacktop,"call-method-by-list",call_method_by_list,2);
  537.   ON_TRACE((void) make_module_function(stacktop,"print-generic-hits",print_hits,0));
  538.  
  539.   close_module();
  540. }
  541.  
  542.  
  543.  
  544. #if 0 /* GENERIC LOOKUP WITH 1st ARG SWITCHING --- case not proven */
  545.       /* then the slow cache */
  546.  
  547. {      tmp=generic_slow_method_cache(gf);
  548.       ptr=tmp;
  549.  
  550.       while(ptr!=nil && CAR(CAR(ptr))!=classof(*stackbase))
  551.     ptr=CDR(ptr);
  552.       
  553.       if (ptr!=nil)
  554.     {
  555.       LispObject tmp2;
  556.  
  557.       tmp2=CAR(tmp);
  558.       CAR(tmp)=CAR(ptr);
  559.       CAR(ptr)=tmp2;
  560.       ptr=CDR(CAR(tmp));
  561.  
  562.       walker=stackbase+1;
  563.       count=1;
  564.       while(ptr!=nil && count<explicit)
  565.         {
  566.           if (CAR(CAR(ptr))==classof(*(walker)))
  567.         {        /* move down 1 */
  568.           ptr=CDR(CAR(ptr));
  569.           walker++;
  570.           count++;
  571.         }
  572.           else
  573.         ptr=CDR(ptr);
  574.         }
  575.       
  576.       if (count==explicit)
  577.         {
  578.           generic_fast_method_cache(gf)=ptr;
  579.  
  580.           return(call_method(stackbase,nargs,CDR(ptr)));
  581.         }
  582.     } 
  583.       /* not in slow cache */
  584.     }
  585. #endif
  586.